home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
fortran
/
fv121s.zip
/
DEMO.FOR
< prev
next >
Wrap
Text File
|
1988-05-28
|
18KB
|
553 lines
c========================================================
c
c demo.for FAT-Video 1.20 Updated 1/28/88
c
c Window demo for FAT-Video 1.20.
c
c This program works with CGA,EGA and MONO
c monitors in modes 3 or 7.
c
c marc a. norton
c=========================================================
INTEGER*2 attr,ulr,ulc,nr,nc,rattr,xattr,i,j,k,l,icol
INTEGER*2 fore,back,inten,blink,mode,ncols,page,battr
INTEGER*2 scan,key,wid1,wid2,wid3,wids,wdx(16),wid0
integer*2 White,Yellow
integer*2 Black,Blue,Red
character title*80,string*80,infil*35,outfil*35
logical POP
character adap*3
INTEGER*2 isel,iopt,ii,ipos,im,ikey
character*20 prnam(10)
character*50 itnam(20),itmen(20)
c----------------------------------------------------------------------
c prnam must be declared as char*20 for compatability with menbar().
c itnam must be declared as char*50 for compatability with wmenu().
c----------------------------------------------------------------------
c------- get adapter
call cls()
call getmod(mode,ncols,page)
call getadp(adap)
IF(mode .eq. 3)THEN
White = 7
Yellow= 6
Black = 0
Blue = 1
Red = 4
END IF
IF(mode .eq. 7)THEN
White = 7
Yellow= 7
Black = 0
Blue = 0
Red = 0
END IF
c--------set border, if were on a true CGA adapter, not EGA in mode 3
c border on EGA is set with the overscan register.
if(adap.eq.'CGA')call setbc(7)
c------opening display-----------------
call opndis(infil,outfil)
call cls()
inten=0
blink=0
call setab(attr,White,Blue,inten,blink)
c---------make borderless backdrop window
call wopen(wids,attr,attr,0,0,23,78,char(0),0,0,0)
105 continue
c----------loc of window of ulr,ulc for window #1
ulr=3
ulc=10
nr = 15
nc = 60
c--------------set window colors
inten= 0
blink= 0
c----------setup the attr byte
call setab(attr,Yellow,Black,inten,blink)
call revab(attr,battr)
c-----------open window #1
title='1: FAT-Video Demo`'
call setnul(title)
call wopen(wid1,battr,attr,ulr,ulc,nr,nc,title,1,0,0)
c-----------write a line of txt
title=' This is a demonstration of the simple`'
call wprint(wid1,title)
title=' windowing that can be performed with the`'
call wprint(wid1,title)
title=' FAT-Video utilities, in Fortran.`'
call wprint(wid1,title)
call wprint(wid1,' Notice, if you have a CGA monitor`')
call wprint(wid1,' the border color is now set, and`')
call wprint(wid1,' we have a background screen to work on. `')
call wcrlf(wid1)
call wprint(wid1,' Press a key to continue...`')
call rdkbd(scan,key)
call wcls(wid1)
call wprint(wid1,' First we will examine some text i/o.`')
call wcrlf(wid1)
call wprint(wid1,' Press a key, and notice the key is echoed`')
call wprint(wid1,' to the screen.`')
call revab(attr,rattr)
call wgetce(wid1,rattr,key)
call wcrlf(wid1)
call wprint(wid1,' Enter a string and press return: `')
call setab(rattr,White,Blue,0,0)
call wgetse(wid1,rattr,string,15)
call wcrlf(wid1)
call wprint(wid1,' Enter a string, and press return,`')
call wprint(wid1,' notice there is no echo.`')
call wgetsn(wid1,string,15)
call wcrlf(wid1)
call wprint(wid1,' Your string was: `' )
call wprint(wid1,string)
call wcrlf(wid1)
call wprint(wid1,' Press a key to continue.`')
call rdkbd(scan,key)
call wcls(wid1)
call wprint(wid1,' These have been some examples of the`')
call wprint(wid1,' kind of text input and output available`')
call wprint(wid1,' with or without the`')
call wprint(wid1,' windows, using the FAT-Video libraries.`')
call wprint(wid1,' Examine the demo source code to see how`')
call wprint(wid1,' easy it is to use the window, and video`')
call wprint(wid1,' library functions. They are all simple`')
call wprint(wid1,' subroutine calls, but they provide some`')
call wprint(wid1,' very powerful tools for writing pleasant`')
call wprint(wid1,' user interfaces.`')
call wcrlf(wid1)
call wprint(wid1,' Press any key to continue...`')
call RDKBD(SCAN,KEY)
call wcls(wid1)
c--------------go to menuing now...
call wprint(wid1,' We will go on to menus now. There are 3`')
call wprint(wid1,' types of menus in FAT-Video. The first is`')
call wprint(wid1,' the menu-bar, it is the master menu and it`')
call wprint(wid1,' appears in row 1 of the window it is`')
call wprint(wid1,' placed in. The second is the Pull-Down menu,`')
call wprint(wid1,' it drops from`')
call wprint(wid1,' under the main menu-item selected. The`')
call wprint(wid1,' third`')
call wprint(wid1,' is the Pop-Up menu, it just pops up on`')
call wpriNT(WID1,' screen`')
call wprint(wid1,' wherever you want.`')
call wprint(wid1,' Before we look at the menus, here`')
call wprint(wid1,' are some simple rules to follow:`')
call wcrlf(wid1)
call wcrlf(wid1)
call wprint(wid1,' To move around, use the arrow keys.`')
call wcrlf(wid1)
call wprint(wid1,' To select a menu-item, press return.`')
call wcrlf(wid1)
call wprint(wid1,' To exit, without selecting, press Esc.`')
call wcrlf(wid1)
call wprint(wid1,' To exit the menus, select Exit.`')
call wcrlf(wid1)
call wcrlf(wid1)
call wprint(wid1,' Thats it, press a key to go on...`')
call RDKBD(SCAN,KEY)
call wcls(wid1)
c-----------DEFINE MAIN MENU ITEMS
prnam(1)='Menus`'
prnam(2)='Disk`'
prnam(3)='Math`'
prnam(4)='Special`'
prnam(5)='Junk`'
prnam(6)='Memory`'
prnam(7)='Exit`'
prnam(8)=char(0)
c---------define Menus-items
itmen(1) = ' Pop-Up Menus `'
itmen(2) = ' Pull-Down Menus `'
itmen(3) = '`'
c----------- define dummy menu items here
itnam(1) = 'item number 1 `'
itnam(2) = 'item number 2 `'
itnam(3) = 'item number 3 `'
itnam(4) = 'item number 4 `'
itnam(5) = 'item number 5 `'
itnam(6) = 'item number 6 `'
itnam(7) = 'item number 7 `'
itnam(8) = 'item number 8 `'
itnam(9) = 'item number 9 `'
itnam(10) = 'item number 10 `'
itnam(11) = 'item number 11 `'
itnam(12) = 'item number 12 `'
itnam(13)=char(0)
c-----------place some text, but not in row #1 !!!
call wsetcp(wid1,2,1)
call wprint(wid1,' As you play with the menuing features`')
call wprint(wid1,' take notice that the sliding-bar menu in`')
call wprint(wid1,' row 1 may have diffent colors than the`')
call wprint(wid1,' Pop-Up and Pull-Down menus. The 1st item`')
call wprint(wid1,' in the Main menu is Menus, it is the only`')
call wprint(wid1,' functional menu in the demo. It can `')
call wprint(wid1,' dynamically switch between Pop-Up and`')
call wprint(wid1,' Pull-Down menus. Try the menus out, and`')
call wprint(wid1,' examine the source code, they are easy to`')
call wprint(wid1,' make and use.`')
POP = .FALSE.
c---------start position of selected menu
call curoff()
ipos = 1
130 call revab(attr,rattr)
call menbar(wid1,prnam,attr,rattr,isel,ipos)
if(isel.eq.7)go to135
if(isel .eq. 0)go to 130
c--------select colors
call setab(xattr,White,Blue,0,0)
C call revab(xattr,rattr)
icol=30
c----------call Pop-Up or Pull-Down Menus
if(POP)then
if(isel.eq.1)then
call wmenu(itmen,attr,rattr,7,icol,prnam(isel),isel)
if(isel.eq.1)POP=.TRUE.
if(isel.eq.2)POP=.FA